Professional Soft Collection 1.02/Professional Soft Collection 1.02.iso/communic/qmodempr/script.pak/HOST.SCR

Text File | 1994-03-01 | 17.4 KB | 699 lines

'
' Host mode script for QmodemPro for Windows.
'
' Version 1.0
'
' Last updated February 26, 1993.
'

'$include 'hostutil.scr'

' Constants

const BS  = chr(8)
const LF  = chr(10)
const CR  = chr(13)
const ESC = chr(27)

const PrelogFileNamePart   = "host.pre"
const MenuFileNamePart     = "host.mnu"
const ProtocolFileNamePart = "host.pro"
const LogoffFileNamePart   = "host.off"
const HelpFileNamePart     = "host.hlp"

const UserFileNamePart      = "host.usr"
const MsgHeaderFileNamePart = "host.hdr"
const MsgDetailFileNamePart = "host.msg"

const MaxMsgLines = 99

' Type declarations

dialog SetupDialog 18, 18, 214, 200
  caption "QmodemPro Host Setup"
  groupbox "Mode", 101, 18, 9, 74, 64
  modeopen as radiobutton "Open", 102, 26, 23, 62, 12
  modeclosed as radiobutton "Closed", 103, 26, 38, 62, 12
  modecallback as radiobutton "Callback", 104, 26, 53, 62, 12
  groupbox "Security", 150, 100, 9, 100, 64
  maxtime as edittext 105, 151, 22, 42, 12
  dospass as edittext 106, 151, 39, 42, 12
  shutdownpass as edittext 107, 151, 56, 42, 12
  rtext "Max time", -1, 108, 25, 41, 8
  rtext "DOS pwd", -1, 108, 41, 41, 8
  rtext "Shutdown pwd", -1, 108, 59, 41, 8
  groupbox "File transfers", 160, 18, 80, 182, 85
  dlpath as edittext 108, 22, 104, 169, 12
  ulpath as edittext 109, 22, 130, 169, 12
  ltext "Download path", -1, 24, 95, 62, 8
  ltext "Upload path", -1, 24, 120, 69, 8
  sysopanypath as checkbox "Sysop can download from any path", 110, 25, 148, 165, 12
  pushbutton "&Modem...", 200, 15, 175, 50, 14
  defpushbutton "OK", IDOK, 80, 175, 50, 14
  pushbutton "Cancel", IDCANCEL, 150, 175, 50, 14
end dialog

dialog ModemSetupDialog 6, 15, 194, 119
  caption "QmodemPro Host Modem Setup"
  groupbox "", -1, 8, 9, 177, 79
  init as edittext 101, 48, 17, 127, 12
  answer as edittext 102, 48, 33, 47, 12
  busy as edittext 103, 48, 49, 47, 12
  ok as edittext 104, 48, 65, 47, 12
  ring as edittext 105, 129, 33, 45, 12
  ringcount as edittext 106, 148, 49, 27, 12
  rtext "&Init", -1, 16, 19, 28, 8
  rtext "&Answer", -1, 12, 34, 33, 8
  rtext "&Busy", -1, 12, 50, 33, 8
  rtext "&OK msg", -1, 13, 66, 32, 8
  rtext "&Ring", -1, 105, 35, 20, 8
  rtext "Ring &Count", -1, 106, 51, 38, 8
  defpushbutton "OK", IDOK, 77, 96, 50, 14
  pushbutton "Cancel", IDCANCEL, 137, 96, 50, 14
end dialog

type TUser
  Name as string*25
  Password as string*20
  Level as integer
  Phone as string*30
end type

type TMessageHeader
  Sender as string*25
  Receiver as string*25
  Subject as string*75
  DateTime as string*20
  Private as integer
  Received as integer
  Killed as integer
  Lines as integer
  Detailpos as long
end type

' connection variables
dim Local as integer
dim Port as integer
dim ModemResult as string
dim BaudRate as long
dim LogonTime as DateTimeRec
dim LogoffTime as DateTimeRec
dim ForceLogoff as integer

dim Setup as SetupDialog
dim ModemSetup as ModemSetupDialog
dim User as TUser
dim MsgLines(MaxMsgLines) as string

dim PrelogFileName as string
dim MenuFileName as string
dim ProtocolFileName as string
dim LogoffFileName as string
dim HelpFileName as string
dim UserFileName as string
dim MsgHeaderFileName as string
dim MsgDetailFileName as string

'$include 'hostcfg.scr'

declare sub PackMessages

' Utility routines

sub GetCurrentTime(dt as DateTimeRec)
  do
    dt.D = Today
    dt.T = CurrentTime
  loop until dt.D = Today
end sub

function MinutesSince(dt as DateTimeRec)
  dim now as DateTimeRec
  call GetCurrentTime(now)
  while now.D > dt.D
    now.D = now.D - 1
    now.T = now.T + SecondsInDay
  wend
  MinutesSince = (now.T - dt.T) / 60
end function

function MinutesUntil(dt as DateTimeRec)
  dim now as DateTimeRec
  call GetCurrentTime(now)
  while dt.D > now.D
    now.D = now.D + 1
    now.T = now.T - SecondsInDay
  wend
  MinutesUntil = (dt.T - now.T) / 60
end function

function TimeLeft as integer
  TimeLeft = MinutesUntil(LogoffTime)
end function

function CallerHungUp as integer
  CallerHungUp = (not Local and not Carrier) or ForceLogoff
end function

sub DoChat
  dim s as string, c as string
  send #Port,
  send #Port, "You are now chatting with the sysop"
  send #Port,
  do
    c = inkey
    if c = "F2" then
      exit do
    end if
    if c = "" and not Local then
      c = inkey(Port)
    end if
    select case c
      case BS
        if len(s) > 0 then
          s = left(s, len(s)-1)
          send #Port, BS; " "; BS;
        end if
      case CR
        send #Port,
        s = ""
      case is >= " "
        if len(c) = 1 then
          s = s + c
          send #Port, c;
          if len(s) >= 79 then
            if instr(s, " ") then
              dim i as integer
              i = len(s)
              while mid(s, i, 1) <> " "
                i = i - 1
              wend
              send #Port, string(len(s)-i, BS); string(len(s)-i, " ")
              s = mid(s, i+1, len(s)-i)
              send #Port, s;
            else
              send #Port,
              s = ""
            end if
          end if
        end if
    end select
  loop until CallerHungUp
  send #Port,
  send #Port,
  send #Port, "Returning you to host mode"
  send #Port,
end sub

function YesNo(x as integer) as string
  if x then
    YesNo = "Yes"
  else
    YesNo = "No"
  end if
end function

declare function GetLine(prompt as string = "", maxlen as integer = 0, start as string = "", passchar as string = "") as string
function GetLine(prompt as string, maxlen as integer, start as string, passchar as string) as string
  dim s as string
  dim starttime as DateTimeRec
  dim warned as integer
  call GetCurrentTime(starttime)
  warned = false
  s = start
  send #Port, prompt; s;
  do
    dim c as string
    c = inkey
    if c = "" and not Local then
      c = inkey(Port)
    end if
    select case c
      case ""
        dim idle as integer
        idle = MinutesSince(starttime)
        if idle >= 4 and not warned then
          send #Port,
          send #Port,
          send #Port, "CAUTION!  You will be logged off if you do not continue in 60 seconds!"
          send #Port,
          send #Port, prompt; s;
          warned = true
        elseif idle >= 5 then
          send #Port,
          send #Port,
          send #Port, "Logged off due to inactivity."
          delay 1
          hangup
          ForceLogoff = True
        end if
      case "F2"
        DoChat
        send #Port, prompt; s;
      case BS
        if len(s) > 0 then
          s = left(s, len(s)-1)
          send #Port, BS;" ";BS;
        end if
      case CR
        GetLine = s
        send #Port,
        exit function
      case ESC
        ' esc handling
      case is >= " "
        s = s + c
        if len(passchar) > 0 then
          send #Port, passchar;
        else
          send #Port, c;
        end if
        if maxlen > 0 and len(s) >= maxlen then
          GetLine = s
          exit function
        end if
    end select
  loop until TimeLeft < 0 or CallerHungUp
  GetLine = ""
end function

function DisplayFile(fn as string) as integer
  dim f as integer, count as integer
  DisplayFile = TRUE
  f = freefile
  open fn for input as #f
  count = 0
  do while not eof(f)
    dim s as string
    input #f, s
    send #Port, s
    count = count + 1
    if count >= 24 then
      if OemUpper(GetLine("-Pause- [C]ontinue, [S]top? ", 1)) = "S" then
        exit do
      end if
      send #Port,
      count = 0
    end if
  loop
  close #f
catch err_fileopen
  DisplayFile = FALSE
end function

sub SendModemString(s as string)
  dim i as integer, c as string
  i = 1
  while i <= len(s)
    c = mid(s, i, 1)
    if c = "^" and i+1 <= len(s) then
      i = i + 1
      c = mid(s, i, 1)
      if c = "~" then
        delay 0.5
        goto nextchar
      else
        c = chr(asc(c) and 0x3f)
      end if
    end if
    send c;
nextchar:
    i = i + 1
  wend
end sub

sub InitModem
  dim result as string
  hostecho off
  if carrier then exit sub
  timeout 5
tryagain:
  delay 1
  SendModemString ModemSetup.init
  do
    receive result
  loop until result = ModemSetup.ok
catch err_timeout
  goto tryagain
end sub

function WaitForCall as integer
  hostecho off
  if carrier then
    Local = False
    Port = comm
    WaitForCall = True
    exit function
  end if
  do
    dim rings as integer
    rings = 0
    dim result as string
    do
      dim c as string
      c = inkey(comm)
      if c = "" then
        c = inkey
        select case OemUpper(c)
          case "F1"
            if ModemSetup.busy <> "" then
              SendModemString ModemSetup.busy
              delay 1
              flush input
            end if
            Local = True
            Port = 0
            WaitForCall = True
            exit function
          case "F7"
            PackMessages
            WaitForCall = False
            exit function
          case "F8"
            SetupHost
          case "F9"
            print "Host mode terminated, returning to normal operation."
            end
        end select
      elseif c = LF then
        result = ""
      else
        result = result + c
        if len(result) > len(ModemSetup.ring) then
          result = right(result, len(result)-1)
        end if
        if result = ModemSetup.ring then
          rings = rings + 1
        end if
      end if
    loop until rings >= val(ModemSetup.ringcount)
    delay 0.2
    SendModemString ModemSetup.answer
    timeout 60
    do
      receive result
      if left(result, 7) = "CONNECT" then
        ModemResult = result
        BaudRate = val(right(ModemResult, len(ModemResult)-8))
        Local = False
        Port = comm
        WaitForCall = True
        exit function
      end if
    loop until result = "NO CARRIER"
  loop
catch err_timeout
  WaitForCall = False
end function

function NextField(s as string, delim as string) as string
  dim i as integer
  i = instr(s, delim)
  if i > 0 then
    NextField = left(s, i-1)
    s = right(s, len(s)-i)
  else
    NextField = s
    s = ""
  end if
end function

function LookupUser(uname as string, user as TUser) as integer
  dim f as integer, s as string
  LookupUser = False
  f = freefile
  open UserFileName for input as #f
  do while not eof(f)
    input #f, s
    dim i as integer
    i = instr(s, ";")
    if i > 0 then
      s = rtrim(left(s, i-1))
    end if
    if OemUpper(uname)+"," = left(s, len(uname)+1) then
      user.Name = NextField(s, ",")
      user.Password = NextField(s, ",")
      user.Level = val(NextField(s, ","))
      user.Phone = NextField(s, ",")
      close #f
      LookupUser = True
      exit function
    end if
  loop
  close #f
catch err_fileopen
end function

function GetPassword as integer
  GetPassword = True
  if User.Password = "" then
    exit function
  end if
  GetPassword = False
  dim password as string, tries as integer
  do
    password = GetLine("Password? ", 0, "", "*")
    if CallerHungUp then
      exit function
    end if
    if OemUpper(password) = OemUpper(User.Password) then
      send #Port, "Password ok"
      GetPassword = True
      exit function
    end if
    tries = tries + 1
    if tries > 3 then
      send #Port,
      send #Port, "Sorry, access denied"
      send #Port,
      exit function
    else
      send #Port,
      send #Port, "Incorrect password entered"
      send #Port,
    end if
  loop
  GetPassword = True
end function

function CallUserBack as integer
  CallUserBack = False
  if User.Phone = "" then
    send #Port, "Your phone number is not on file."
    send #Port, "(click)"
    exit function
  end if
  send #Port, "Hanging up now, type ATA and press Enter after you get a ring."
  delay 1
  hostecho off
  hangup
  delay 10
  send "ATDT"; User.Phone
  timeout 60
  dim result as string
  do
    receive result
    if left(result, 7) = "CONNECT" then
      ModemResult = result
      BaudRate = val(right(ModemResult, len(ModemResult)-8))
      exit do
    end if
  loop
  timeout off
  hostecho on
  delay 1
  send #Port, "Welcome "; User.Name
  send #Port,
  if GetPassword then
    CallUserBack = True
  end if
catch err_timeout
  send
end function

function GetCallerInfo as integer
  dim uname as string
  do
    uname = OemUpper(GetLine("Please enter your name? "))
    if CallerHungUp then
      GetCallerInfo = False
      exit function
    end if
    if LookupUser(uname, User) then
      if not GetPassword then
        GetCallerInfo = False
        exit function
      end if
      if Setup.modecallback and not Local then
        if not CallUserBack then
          GetCallerInfo = False
          exit function
        end if
      end if
      GetCallerInfo = True
      exit function
    elseif Setup.modeopen then
      User.Name = uname
      send #Port,
      send #Port, "Your name ";chr(34);uname;chr(34);" was not found in the user list."
      if OemUpper(left(GetLine("Is it spelled correctly? "), 1)) = "Y" then
        exit do
      end if
      send #Port,
    else
      send #Port,
      send #Port, "Sorry, you are not registered with this system."
      send #Port, "(click)"
      send #Port,
      GetCallerInfo = False
      exit function
    end if
  loop
  send #Port,
  do
    dim password as string
    User.Password = GetLine("Please select a password? ", 0, "", "*")
    password      = GetLine("Type your password again? ", 0, "", "*")
    if OemUpper(password) = OemUpper(User.Password) then exit do
    send #Port,
    send #Port, "The passwords you typed did not match.  Try again."
    send #Port,
  loop
  User.Level = 0
  open UserFileName for append as #1
  print #1, User.Name;",";User.Password;",";User.Level
  close #1
  send #Port, "Welcome new user!"
  GetCallerInfo = True
catch err_fileopen
  send "Fatal error - could not open user database"
  GetCallerInfo = False
end function

'$include 'hostfile.scr'
'$include 'hostmsg.scr'
'$include 'hostdos.scr'

sub HelpScreen
  if DisplayFile(HelpFileName) then
    do
      dim s as string
      send #Port,
      send #Port, "Type the letter of the command you would like more help with,"
      s = OemUpper(GetLine("or press Enter to return to the main menu: "))
      if s = "" or CallerHungUp then exit do
      send #Port,
      if not DisplayFile(ConfigScriptPath+"\host" + left(s, 1) + ".hlp") then
        send #Port, "Sorry, no help is available for that item."
      end if
    loop
  else
    send #Port, "Sorry, no help information is available."
  end if
end sub

' Page sysop

sub PageSysop
  send #Port, "Paging sysop..."
  print "(Sysop: Press F2 to enter chat mode)"
  play "RINGIN"
  send #Port,
  GetLine "Press Enter to continue? "
end sub

sub Shutdown
  if User.Level = 0 or Setup.shutdownpass = "" then
    send #Port, "Sorry, shutdown option not available."
    send #Port,
    exit sub
  end if
  if OemUpper(GetLine("Enter shutdown password: ", 0, "", "*")) <> OemUpper(Setup.shutdownpass) then
    send #Port,
    send #Port, "Wrong password entered."
    send #Port,
    exit sub
  end if
  hangup
  end
end sub

do
  PrelogFileName    = ConfigScriptPath+"\"+PrelogFileNamePart
  MenuFileName      = ConfigScriptPath+"\"+MenuFileNamePart
  ProtocolFileName  = ConfigScriptPath+"\"+ProtocolFileNamePart
  LogoffFileName    = ConfigScriptPath+"\"+LogoffFileNamePart
  HelpFileName      = ConfigScriptPath+"\"+HelpFileNamePart
  UserFileName      = ConfigScriptPath+"\"+UserFileNamePart
  MsgHeaderFileName = ConfigScriptPath+"\"+MsgHeaderFileNamePart
  MsgDetailFileName = ConfigScriptPath+"\"+MsgDetailFileNamePart
  LoadConfig
  InitModem
  do
    cls
    print "QmodemPro for Windows Host Mode"
    print
    print "Press F1 to log on locally"
    print "Press F7 to pack the messages"
    print "Press F8 to set up the host mode"
    print "Press F9 to quit the host mode"
    print
    print "Modem ready for calls..."
  loop until WaitForCall
  timeout off
  ForceLogoff = False
  print "Call connected at "; BaudRate; " baud"
  hostecho on
  delay 1
  send #Port, "Welcome to the Qmodem for Windows host mode!"
  send #Port,
  send #Port, "Modem result: "; ModemResult
  send #Port, "Connected at "; BaudRate; " bps. ";
  send #Port,
  send #Port,
  DisplayFile PrelogFileName
  call GetCurrentTime(LogonTime)
  call IncDateTime(LogonTime, LogoffTime, 0, val(Setup.MaxTime)*60)
  if GetCallerInfo then
    do
      send #Port,
      DisplayFile MenuFileName
      dim cmd as string
      cmd = GetLine("("+str(TimeLeft)+" min. left) Command? ")
      send #Port,
      select case OemUpper(cmd)
        case "?"
          HelpScreen
        case "D"
          DownloadFile
        case "E"
          EnterMessage
        case "F"
          ListFiles
        case "G"
          DisplayFile LogoffFileName
          send #Port, "Thanks for calling!"
          exit do
        case "P"
          PageSysop
        case "R"
          ReadMessages
        case "S"
          DosShell
        case "U"
          UploadFile
        case "Z"
          Shutdown
        case else
          send #Port, "Unknown command, try again"
      end select
    loop until TimeLeft < 0 or CallerHungUp
  end if
  hostecho off
  if not Local then
    delay 1
    hangup
    delay 1
  end if
loop